PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/prftest.exe/PROFUNIT.PAS

Pascal/Delphi Source File | 1992-04-14 | 14.7 KB | 466 lines

Unit ProfUnit;

{=====================================================================}
{===== This code implements two standard Windows functions,      =====}
{===== WritePrivateProfileString and GetPrivateProfileString.    =====}
{===== In addition, a parsing function is included,              =====}
{===== ParseProfileString, which is useful for parsing the       =====}
{===== buffer returned by the Get... function.  This Pascal      =====}
{===== implementation is an attempt to apply those functions     =====}
{===== as well as the general notion of the ".INI" file to       =====}
{===== DOS environment.  I've tried to make the functions        =====}
{===== work exactly like their Windows API counterparts.  To     =====}
{===== differentiate between the environments, my functions are  =====}
{===== called WriteDOSProfileString and GetDOSProfileString.     =====}
{=====                                                           =====}
{===== Note that the arguments for all functions ARE CASE        =====}
{===== SENSITIVE.  I will be adding code to resolve that as soon =====}
{===== as I have the chance.  If there is any interest in this   =====}
{===== code, I will upload updates as they are implemented.  If  =====}
{===== there are any suggestions, please email to me on either:  =====}
{=====                                                           =====}
{=====          X.400:(c=us,a=attmail,d=id:mvabbc!wmpotvin)      =====}
{=====   or                                                      =====}
{=====          70540,120                                        =====}
{=====                                                           =====}
{===== Copyright(c) 1992 Wm Potvin II                            =====}
{=====================================================================}

Interface

Uses
  Dos;

Type
  StrArray = array [1..80] of String[80];
  ProfStr = String[255];
  LinePtr = ^LineRecType;
  LineRecType = Record
    NextLine  : LinePtr;
    LineField : ProfStr;
  end;

Var
  P1, P2, P3,
  KeyUpDated,
  AppUpDated,
  KeyFound,
  AppFound   : Boolean;
  F          : Text;                     { File handle    }
  Head       : LinePtr;                  { Head of List   }
  Hold       : LinePtr;                  { Place Holder   }
  Cur        : LinePtr;                  { Current Line   }
  LineBuf    : ProfStr;                  { Input String   }
  LineFieldIndex,
  Count,
  CountEnd,
  Index,
  BufIndex : Integer;

function WriteDOSProfileString(AppName,
                               KeyName,
                               Str: String;
                               FileName: PathStr): Boolean;

function GetDOSProfileString(AppName,
                             KeyName,
                             Default: ProfStr;
                             var RecvBuf: ProfStr;
                             Size: Integer;
                             FileName: PathStr): Integer;

function ParseProfileString(ProfileBuffer: ProfStr;
                            var ReturnedArray: StrArray): Integer;

function ASCIIToUpper(StrBuffer: String): String;

Implementation

function WriteDOSProfileString(AppName,
                               KeyName,
                               Str: String;
                               FileName: PathStr): Boolean;

 {***** Support Functions *****}

  function DeleteLine(DeleteStr: ProfStr): Boolean;
  { deletes the line of the buffer containing DeleteStr. }
  var
    Count : Integer;
  begin
    DeleteLine := FALSE;
    Hold := Head;
    Cur := Head^.NextLine;
    Count := 1;
    while (Cur <> NIL) AND (Pos(DeleteStr, Cur^.LineField) = 0) do
      begin
        Hold := Cur;              { Save Current pointer }
        Cur  := Cur^.NextLine;    { Advance to next line }
      end;
    if (Cur <> NIL) AND (Pos(DeleteStr, Cur^.LineField) <> 0) then
      begin
        Hold^.NextLine := Cur^.NextLine; {  skip current line }
        FreeMem(Cur, Length(Cur^.LineField) + 5);
        DeleteLine := TRUE;
      end;
  end;

  function DeleteAppName(DeleteAppStr: ProfStr): Boolean;
  { deletes an entire App Section of the buffer containing DeleteAppStr. }
  var
    Count : Integer;
  begin
    DeleteAppName := FALSE;
    Hold := Head;
    Cur := Head^.NextLine;
    while (Cur <> NIL) AND (Pos(DeleteAppStr, Cur^.LineField) < 2) do
      begin
        Hold := Cur;              { Save Current pointer }
        Cur  := Cur^.NextLine;    { Advance to next line }
      end;
    if (Cur <> NIL) AND (Pos(DeleteAppStr, Cur^.LineField) <> 0) then
      begin
        while (Cur <> NIL) AND (Cur^.LineField <> ' ') do
          begin
            Hold^.NextLine := Cur^.NextLine; {  skip current line }
            FreeMem(Cur, Length(Cur^.LineField) + 5);
            Cur := Hold^.NextLine;
          end;
        DeleteAppName := TRUE;
      end;
  end;

  function InsertLine(NewStr: ProfStr): Boolean;
  { inserts the line ProfStr after the last line under the AppName. }
  var
    NewLine: LinePtr;
  begin
    InsertLine := FALSE;
    Hold := Head;
    Cur  := Head^.NextLine;
    while (Cur <> NIL) do
      begin
        Hold  := Cur;                      { Save current pointer }
        Cur   := Cur^.NextLine;            { Advance to next line }
        if (Hold^.LineField = '') AND      { if the old line is blank, }
          (Cur^.LineField = '') then       { and the current line, too }
            Cur := NIL;
      end;
    GetMem(NewLine, Length(NewStr) + 5);
    Hold^.NextLine := NewLine;    { Change pointers to link }
    NewLine^.NextLine := Cur;     {   in the new line       }
    NewLine^.LineField := NewStr;
    InsertLine := TRUE;
  end;

  function InsertAppName(NewApp: ProfStr): Boolean;
  var
    P4, P5: Boolean;
  begin
    P4 := InsertLine('');
    P5 := InsertLine(ConCat('[', AppName, ']'));
  end;

  function LoadFile: Boolean;
  {loads the file into a linked list }
  begin
    FileName := FExpand(FileName);
    Assign(F, FileName);
    {$I-}
    Reset(F);
    {I+} ;
    if (IOResult = 0) then
      begin
        GetMem(Head, 4);
        Head^.NextLine := NIL;              { Initialize Head }
        Hold := Head;
        while NOT Eof(F) do
          begin
            ReadLn(F, LineBuf);
            GetMem(Cur, Length(LineBuf)+5); { Allocate Memory }
            Hold^.NextLine := Cur;          { Set previous pointer }
            Cur^.NextLine  := NIL;          { Cur goes at end of list }
            Hold := Cur;                    { Save Current pointer }
            Cur^.LineField := LineBuf;
          end;
        Close(F);
        LoadFile := TRUE;
      end
    else
      LoadFile := FALSE
  end;

  function WriteFile: Boolean;
  { traverse the list and write each line }
  begin
    FileName := FExpand(FileName);
    Assign(F, FileName);
    {$I-}
    ReWrite(F);
    {I+} ;
    if (IOResult = 0) then
      begin
        Cur := Head^.NextLine;
        while Cur <> NIL do
          begin
            WriteLn(F, Cur^.LineField);
            Cur := Cur^.NextLine;
          end;
        Close(F);
        WriteFile := TRUE;
      end
    else
      WriteFile := FALSE;
  end;

  {***** Begin Main Function *****}

begin
  P1 := LoadFile;
  if P1 then
    begin
      Cur := Head^.NextLine;
      KeyUpDated := FALSE;
      AppUpDated := FALSE;
      while Cur <> NIL do
        begin
          if (KeyName = 'nil') then
            begin
              P3 := DeleteAppName(AppName);
              P3 := WriteFile;
              if P3 then
                WriteDOSProfileString := TRUE
              else
                WriteDOSProfileString := FALSE;
              Exit;
            end
          else
          if Pos(AppName, Cur^.LineField) = 2 then
            begin
              while NOT AppUpdated do
              begin
              AppUpdated := TRUE;
              Cur := Cur^.NextLine;
              if Pos(KeyName, Cur^.LineField) = 1 then
                begin
                  if (Str = 'nil') then
                    begin
                      P3 := DeleteLine(KeyName);
                      P3 := WriteFile;
                      if P3 then
                        WriteDOSProfileString := TRUE
                      else
                        WriteDOSProfileString := FALSE;
                      Exit;
                    end
                  else
                    begin
                      Cur^.LineField := ConCat(KeyName, '=', Str);
                      P3 := WriteFile;
                      if P3 then
                        WriteDOSProfileString := TRUE
                      else
                        WriteDOSProfileString := FALSE;
                      Exit;
                    end;
                end
              else
                if (Cur^.LineField = '') OR (Cur = NIL) then
                  begin
                    P3 := InsertLine(ConCat(KeyName, '=', Str));
                    P3 := WriteFile;
                    if P3 then
                      WriteDOSProfileString := TRUE
                    else
                      WriteDOSProfileString := FALSE;
                    Exit;
                  end
                else
                  AppUpdated := FALSE;
            end;
          end;
          Cur := Cur^.NextLine;
        end;
      if (Cur = NIL) AND NOT AppUpdated then
        begin
          P3 := InsertAppName(AppName);
          P3 := InsertLine(ConCat(KeyName, '=', Str));
        end;
      P2 := WriteFile;
      if P2 then
        WriteDOSProfileString := TRUE
      else
        WriteDOSProfileString := FALSE;
    end
  else
    begin
      {$I-}
      ReWrite(F);
      {$I+}
      if IOResult = 0 then
        begin
          WriteLn(F);
          WriteLn(F, '[', AppName, ']');
          WriteLn(F, KeyName, '=', Str);
          {$I-}
          Close(F);
          {$I+}
          if IOResult = 0 then
            WriteDOSProfileString := TRUE
          else
            WriteDOSProfileString := FALSE;
        end
      else
        WriteDOSProfileString := FALSE;
    end;
end;

{***** End of function WriteDOSProfileString *****}

{***** Begin function GetDOSProfileString *****}

function GetDOSProfileString(AppName,
                             KeyName,
                             Default: ProfStr;
                             var RecvBuf: ProfStr;
                             Size: Integer;
                             FileName: PathStr): Integer;

 {***** Support Functions *****}

  function LoadFile: Boolean;
  {loads the file into a linked list }
  begin
    FileName := FExpand(FileName);
    Assign(F, FileName);
    {$I-}
    Reset(F);
    {I+} ;
    if (IOResult = 0) then
      begin
        GetMem(Head, 4);
        Head^.NextLine := NIL;              { Initialize Head }
        Hold := Head;
        while NOT Eof(F) do
          begin
            ReadLn(F, LineBuf);
            GetMem(Cur, Length(LineBuf)+5); { Allocate Memory }
            Hold^.NextLine := Cur;          { Set previous pointer }
            Cur^.NextLine  := NIL;          { Cur goes at end of list }
            Hold := Cur;                    { Save Current pointer }
            Cur^.LineField := LineBuf;
          end;
        Close(F);
        LoadFile := TRUE;
      end
    else
      LoadFile := FALSE
  end;

begin
  P1 := LoadFile;
  if P1 then
    begin
      Cur := Head^.NextLine;
      AppFound := FALSE;
      KeyFound := FALSE;
      while Cur <> NIL do
        begin
          if (Pos(AppName, Cur^.LineField) <> 0) then
            begin
              AppFound := TRUE;
              while AppFound do
              begin
              if (KeyName = 'nil') then
                begin
                  Cur := Cur^.NextLine;
                  while (Cur^.LineField <> '') AND (Cur <> NIL) do
                    begin
                      LineFieldIndex := 1;
                      BufIndex := 1;
                      LineFieldIndex := Pos('=', Cur^.LineField);
                      if KeyFound then
                        RecvBuf := ConCat(RecvBuf, Copy(Cur^.LineField, 1, LineFieldIndex - 1))
                      else
                        RecvBuf := Copy(Cur^.LineField, 1, LineFieldIndex - 1);
                      Cur := Cur^.NextLine;
                      if (Cur <> NIL) then
                        RecvBuf := ConCat(RecvBuf, ',');
                      KeyFound := TRUE;
                    end;
                  Cur := NIL;
                end;
              if (KeyName = Copy(Cur^.LineField, 1, Pos('=', Cur^.LineField)-1))
                AND NOT KeyFound then
                begin
                  LineFieldIndex := 1;
                  BufIndex := 1;
                  while Cur^.LineField[LineFieldIndex] <> '=' do
                    inc(LineFieldIndex);
                  CountEnd :=(Length(Cur^.LineField) - LineFieldIndex);
                  RecvBuf := Copy(Cur^.LineField, LineFieldIndex + 1, CountEnd);
                  if RecvBuf = ' ' then RecvBuf := Default;
                  KeyFound := TRUE;
                end
              else
                if (Cur <> NIL) then
                  begin
                    AppUpdated := FALSE;
                    Cur := Cur^.NextLine;
                  end
                else
                  AppFound := FALSE;
              end;
            end;
          if Cur <> NIL then Cur := Cur^.NextLine;
        end;
      if NOT KeyFound then RecvBuf := Default;
    end;
  GetDOSProfileString := Length(RecvBuf);
end;

 {***** End of function GetDOSProfileString *****}

 {***** Begin function ParseProfileString *****}

function ParseProfileString(ProfileBuffer: ProfStr;
                            var ReturnedArray: StrArray): Integer;
var
  Count, Start, NumBytes: Integer;
  Done: Boolean;
begin
  Start := 1;
  Count := 0;
  Done := FALSE;
  while NOT Done do
    begin
      NumBytes := Pos(',', ProfileBuffer);
      if NumBytes = 0 then
        begin
          NumBytes := Length(ProfileBuffer);
          Done := TRUE;
        end;
      if NOT Done then
        ReturnedArray[Count] := Copy(ProfileBuffer, 1, NumBytes - 1)
      else
        ReturnedArray[Count] := Copy(ProfileBuffer, 1, NumBytes);
      ProfileBuffer := Copy(ProfileBuffer, NumBytes + 1, Length(ProfileBuffer) - NumBytes);
      inc(Count);
    end;
  ParseProfileString := Count;
end;

 {***** End of function ParseProfileString *****}

function ASCIIToUpper(StrBuffer: String): String;
var
  Index: Integer;
begin
  for Index := 1 to Length(StrBuffer) do
    begin
      StrBuffer[Index] := UpCase(StrBuffer[Index]);
    end;
end;


end.